(FILECREATED "10-OCT-73 05:57:11" RECORD)


(LISPXPRINT (QUOTE RECORDVARS) T)
(RPAQQ RECORDVARS ((FNS TYPERECORD RECORD RECORD1 CLISPRECORD RECORDECL
RECCOMPOSE0 'CAR 'CDR 'CONS RECCOMPOSE1 RECCOMPOSE2 RECCOMPOSE4 
MAKECROPFN1 FIELDSIN /PUTDTST FIELDDEFS MYSUBST MAKERPLAC2 
RECORDCLISPLOOKUP RECRESPELL CLISPNOTRAN CREATE? GETLOCALDEC RECLOOK
DWIMIFYREC EASYCOMPUTE GLOBALRECORD CLISPGLOBALREC RECLISPLOOKUP GETSETQ
RECORDERROR) (PROP CLISPWORD CREATE create USING using) (PROP PRETTYTYPE
RECORDS) (ADDVARS (PRETTYTYPELST (CHANGEDRECLST RECORDS "records"))
(PRETTYMACROS (RECORDS X (E (MAPC (QUOTE X) (FUNCTION (LAMBDA (Z)
(PRINT (SELECTQ (CAR (SETQ Z (CLISPNOTRAN (OR (LISTP Z) (LISTP (GETP
Z (QUOTE RECORD))))))) ((RECORD TYPERECORD) Z) (ERROR Z "not a record"))))))))))
(VARS CRLIST (RECORDSPLIST (LIST NIL)) (CHANGEDRECLST NIL) (USERRECORDS
NIL) (RECORDTRANFLG T) RECORDREPLACEVALUEFLG) (BLOCKS (RECORDBLOCK
TYPERECORD RECORD CLISPRECORD RECRESPELL RECLOOK DWIMIFYREC RECORDECL
RECCOMPOSE0 'CAR 'CDR 'CONS RECCOMPOSE1 RECCOMPOSE2 RECCOMPOSE4 
MAKECROPFN1 FIELDSIN /PUTDTST FIELDDEFS MYSUBST RECORDCLISPLOOKUP
MAKERPLAC2 CREATE? GETLOCALDEC EASYCOMPUTE (ENTRIES RECORD TYPERECORD
RECCOMPOSE0 CLISPRECORD RECORDECL CLISPNOTRAN) (LOCALFREEVARS FROMVAR
SUBSTEXPR ALIST COMPOSESTATEMENT) (GLOBALVARS RECORDSPLIST CRLIST
USERRECORDS CHANGEDRECLST RECORDREPLACEVALUEFLG) (SPECVARS VARS)))
(P (ADDSPELL (QUOTE CREATE) SPELLINGS2) (ADDSPELL (QUOTE USING) 
SPELLINGS2))))
(DEFINEQ

(TYPERECORD
(NLAMBDA NAME&FIELDS (PROG (TEM) (RECORD1 (CONS (QUOTE TYPERECORD)
NAME&FIELDS)) (AND RECORDTRANFLG (/PUT (SETQ TEM (MKATOM (CONCAT (CAR
NAME&FIELDS) "?"))) (QUOTE MACRO) (CDR (/PUTDTST TEM (LIST (QUOTE
LAMBDA) (QUOTE (RECORDVAR)) (LIST (QUOTE EQ) (QUOTE (CAR RECORDVAR))
(KWOTE (CAR NAME&FIELDS)))))))) (CAR NAME&FIELDS))))

(RECORD
(NLAMBDA NAME&FIELDS (RECORD1 (CONS (QUOTE RECORD) NAME&FIELDS))))

(RECORD1
(LAMBDA (DECL) (PROG (FNF REDECLARELST TEM NAME) RETRY (SETQ NAME
(AND (NLISTP (CADR DECL)) (CADR DECL))) (COND ((AND (NULL (CDR DECL))
(SETQ TEM (GETP NAME (QUOTE CLISPRECORD)))) (* FEATURE: SAYING (RECORD
FOO) IF FOO HAS A CLISPRECORD PROP, JUST REDECLARES FOO - USEFUL IF
YOU EDIT THE PROPERTY) (SETQ TEM (CLISPNOTRAN TEM)) (SETQ DECL (CONS
(CAR TEM) (CDR TEM))) (GO RETRY))) (SETQ FNF (RECORDECL DECL)) (COND
(NAME (COND ((SETQ TEM (GETP NAME (QUOTE CLISPRECORD))) (SETQ 
REDECLARELST (CONS (CADR (CLISPNOTRAN TEM)) (CAR (SETQ TEM (RECORDECL
TEM))))) (* REDCLARELST is used for the MAPHASH) (MAPC (CAR TEM) (F/L
(X) (/REMPROP X (QUOTE CLISPRECORD)))) (AND (NULL DFNFLG) (LISPXPRINT
(CONS NAME (QUOTE (redeclared))) T)))) (COND (DWIMFLG (SETQ USERRECORDS
(CONS NAME USERRECORDS)) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /RPLACA)
(QUOTE USERRECORDS) (CDR USERRECORDS)))))) (/PUT NAME (QUOTE CLISPRECORD)
DECL))) (COND ((AND (NULL DFNFLG) FILEPKGFLG) (FRPLACA (QUOTE 
CHANGEDRECLST) (CONS (OR NAME DECL) (CAR (QUOTE CHANGEDRECLST))))
(AND LISPXHIST (UNDOSAVE (LIST (QUOTE /RPLACA) (CAR (QUOTE CHANGEDRECLST)))
LISPXHIST)))) (FRPLACD (CDDR FNF) (FIELDDEFS (CADDR FNF))) (MAPC (CDDDR
FNF) (FUNCTION (LAMBDA (FIELD) (PROG NIL (COND ((AND (GETP (CAR FIELD)
(QUOTE CLISPRECORD)) (NOT (FMEMB (CAR FIELD) REDECLARELST))) (SETQ
REDECLARELST (CONS (CAR FIELD) REDECLARELST)) (AND (NULL DFNFLG) (
LISPXPRINT (CONS (CAR FIELD) (QUOTE (redeclared))))))) (ADDSPELL (CAR
FIELD) RECORDSPLIST) (/PUT (CAR FIELD) (QUOTE CLISPRECORD) DECL) (OR
RECORDTRANFLG (GLOBALRECORD FIELD)))))) (AND REDECLARELST CLISPARRAY
(MAPHASH CLISPARRAY (FUNCTION (LAMBDA (X Y) (AND X (FMEMB (CAR Y)
(QUOTE (create CREATE fetch FETCH replace REPLACE))) (FMEMB (CADR
Y) REDECLARELST) (/PUTHASH Y NIL CLISPARRAY)))))) (RETURN NAME))))

(CLISPRECORD
(LAMBDA (RECEXPR FIELD SETQFLG) (PROG (TEM1 TEM2 DECLST) (* Handles
records. When FIELD is NIL, RECEXPR is an expression such as (fetch
--) or (replace --) %. In this case, CLISPRECORD is to do the 
appropriate lookups and construct the appropriate expresson, which
it returns as its value. it should also do the hashing. Note that
even if there are no local declaration, only global ones, it shuld
still construct the expression and hash on it. If there are no local
or global declaration, return NIL. I will handle the error.) RETRY
(COND ((AND FIELD (NLISTP FIELD)) (COND ((AND (SETQ DECLST (GETLOCALDEC
EXPR FAULTFN)) (SETQ TEM1 (CLISPLOOKUP0 FIELD RECEXPR NIL DECLST NIL
(QUOTE RECORDFIELD)))) (* Local declaration, it's ok) (SETQ TEM2 (
RECORDECL TEM1))) ((FMEMB FIELD (CAR (SETQ TEM2 (RECORDECL (SETQ TEM1
(GETP FIELD (QUOTE CLISPRECORD))))))) (* Global declaration) (OR 
RECORDTRANFLG (GO GLOBAL))) ((SETQ TEM1 (RECRESPELL FIELD DECLST NIL))
(SETQ FIELD TEM1) (GO RETRY)) ((SETQ TEM1 (GETP FIELD (QUOTE ACCESSFN)))
(AND (ATOM TEM1) (SETQ TEM1 (GETP TEM1 (QUOTE ACCESSFN)))) (RETURN
(COND (SETQFLG (LIST (QUOTE replace) (QUOTE ACCESSFN) (OR (CDR (LISTP
TEM1)) (HELP)) RECEXPR)) (T (LIST (COND ((NLISTP TEM1) TEM1) (T (CAR
TEM1))) RECEXPR))))) (T (RETURN))) (AND SETQFLG (RETURN (LIST (QUOTE
replace) FIELD TEM1 RECEXPR))) (SETQ RECEXPR (LIST (QUOTE fetch) FIELD
(QUOTE of) RECEXPR))) (SETQFLG (OR (EQ (CAR RECEXPR) (QUOTE replace))
(HELP)) (COND ((EQ (CADR RECEXPR) (QUOTE GLOBAL)) (GO GLOBAL2)) ((EQ
(CADR RECEXPR) (QUOTE ACCESSFN)) (FRPLACD (CDDDR RECEXPR) FIELD) (*
Can FRPLACD since this is structure that we built) (RETURN (CDDR RECEXPR))))
(* Second pass - Already done spelling correction) (SETQ TEM2 (RECORDECL
(SETQ TEM1 (CADDR RECEXPR)))) (FRPLACA (CDDR RECEXPR) (QUOTE of))
(FRPLACD (CDDDR RECEXPR) (CONS (QUOTE with) FIELD))) (T (* User typein)
(SETQ TEM1 (OR (AND (SETQ DECLST (GETLOCALDEC EXPR FAULTFN)) (
CLISPLOOKUP0 (CADR RECEXPR) (CADDDR RECEXPR) NIL DECLST NIL (QUOTE
RECORDFIELD))) (GETP (CADR RECEXPR) (QUOTE CLISPRECORD)) (AND (
RECRESPELL (CADR RECEXPR) DECLST (CDR RECEXPR)) (GO RETRY)) (RETURN)))
(SELECTQ (CADDR RECEXPR) ((of OF)) (OR (FIXSPELL (CADDR RECEXPR) 70
(QUOTE (of OF)) NIL (CDDR RECEXPR) NIL T) (RETURN))) (SELECTQ (CAR
RECEXPR) ((REPLACE replace) (SELECTQ (CAR (CDDDDR RECEXPR)) ((with
WITH)) (OR (FIXSPELL (CAR (CDDDDR RECEXPR)) 70 (QUOTE (with WITH))
NIL (CDDDDR RECEXPR) NIL T) (RETURN)))) ((FETCH fetch)) (HELP))))
(SETQ TEM1 (OR TEM2 (RECORDECL TEM1) (HELP))) (* Tem1 is the GETHASH
of the RECORD declaration; recexpr is the replace or fetch expression)
(OR (CDDDR TEM1) (FRPLACD (CDDR TEM1) (FIELDDEFS (CADDR TEM1)))) (OR
(SETQ TEM1 (FASSOC (CADR RECEXPR) (CDDDR TEM1))) (HELP)) (CLISPTRAN
RECEXPR (SELECTQ (CAR RECEXPR) ((REPLACE replace) (OR (CDDR TEM1)
(RPLACD (CDR TEM1) (LIST (MAKERPLAC2 (CADR TEM1))))) (SETQ TEM2 (CONS
(RECLISPLOOKUP (CAR (SETQ TEM1 (CADDR TEM1))) (CADDDR RECEXPR) DECLST
(GETP (CAR TEM1) (QUOTE LISPFN))) (CONS (COND ((LISTP (CADR TEM1))
(PROG ((SUBSTEXPR (LIST (CADDDR RECEXPR)))) (OR (MYSUBST (CADR TEM1))
(HELP)))) (T (CADDDR RECEXPR))) (CDR (CDDDDR RECEXPR))))) (COND (
RECORDREPLACEVALUEFLG (LIST (SELECTQ (CAR TEM2) ((RPLACA /RPLACA FRPLACA)
(QUOTE CAR)) ((RPLACD /RPLACD FRPLACD) (QUOTE CDR)) (HELP)) TEM2))
(T TEM2))) ((FETCH fetch) (PROG ((SUBSTEXPR (CDDDR RECEXPR))) (OR
(MYSUBST (CADR TEM1)) (HELP)))) (HELP))) (RETURN RECEXPR) GLOBAL2
(RETURN (CONS (RECLISPLOOKUP (SETQ TEM1 (CAR (CDDDDR (CAR (CDDDDR
RECEXPR))))) (CADDR RECEXPR) (GETLOCALDEC EXPR FAULTFN) (GETP TEM1
(QUOTE LISPFN))) (CONS (CADDR RECEXPR) FIELD))) GLOBAL (COND (SETQFLG
(RETURN (LIST (QUOTE replace) (QUOTE GLOBAL) RECEXPR FIELD TEM1)))
((NOT (FGETD (SETQ TEM1 (CADDDR (FASSOC FIELD (CDDDR (RECORDECL TEM1)))))))
(HELP)) (T (RETURN (LIST TEM1 RECEXPR)))))))

(RECORDECL
(LAMBDA (DECL DWIMDEFAULT) (PROG NIL (OR (LISTP DECL) (RETURN)) (AND
(EQ (CAR DECL) CLISPTRANFLG) (RETURN (CADR DECL))) (RETURN (SELECTQ
(CAR DECL) ((RECORD TYPERECORD) (OR (GETHASH DECL CLISPARRAY) (PROG
(NAME FIELDS) (AND (OR (COND ((OR (EQ (CAR DECL) (QUOTE TYPERECORD))
(NLISTP (CADR DECL))) (SETQ NAME (CADR DECL)) (SETQ FIELDS (CADDR
DECL)) (CDDDR DECL)) (T (SETQ NAME NIL) (SETQ FIELDS (CADR DECL))
(CDDR DECL))) (LISTP NAME) (NLISTP FIELDS)) (ERROR 
"bad record declaration" DECL)) (CLISPTRAN DECL (SETQ NAME (LIST (
FIELDSIN FIELDS) NAME (COND ((EQ (CAR DECL) (QUOTE TYPERECORD)) (CONS
NIL FIELDS)) (T FIELDS))))) (RETURN NAME)))) NIL)))))

(RECCOMPOSE0
(LAMBDA (COMPOSESTATEMENT) (PROG (ALIST COPYING CREATE DECL DEF DEFAULTS
FIELDS TEM TEM1 TEMVAR TYPERECORDFLG USING) (* Constructs a composition
of FIELD using things from L - First L must be split up into things
in field) (SETQ CLISPCHANGE T) (* Tell DWIMIFY not to process further)
LPX (COND ((SETQ CREATE (SOME COMPOSESTATEMENT (FUNCTION CREATE?)))
(SETQ FIELDS (RECORDECL (SETQ DECL (RECLOOK (CADR CREATE) (CDR CREATE)
(GETLOCALDEC EXPR FAULTFN))))))) (COND (TEM (OR CREATE (ERROR 
"no CREATE in" COMPOSESTATEMENT T))) (T (DWIMIFYREC (CDR 
COMPOSESTATEMENT) (NCONC (AND CREATE (APPEND (CAR FIELDS) (LIST (CADR
CREATE)))) (APPEND (QUOTE (CREATE create USING using COPYING copying
DEFAULT default)))) COMPOSESTATEMENT) (COND ((NOT CREATE) (SETQ TEM
T) (GO LPX))))) (SETQ DECL (CLISPNOTRAN DECL)) (* DECL is the actual
declaration (used for determining TYPERECORD) and fields is the hashed
declaration - (fieldlist defaults fields ...)) (SETQ TYPERECORDFLG
(AND (EQ (CAR DECL) (QUOTE TYPERECORD)) (CADR DECL))) (SETQ TEM 
COMPOSESTATEMENT) (SETQ ALIST (MAPCAR (CAR FIELDS) (FUNCTION (LAMBDA
(X) (LIST X))))) LP2 (COND ((AND (NLISTP (CAR TEM)) (SELECTQ (CAR
TEM) ((CREATE create) (* already handled) T) ((using USING) (SETQ
USING TEM)) ((COPYING copying) (SETQ COPYING TEM)) ((default DEFAULT)
(SETQ DEFAULT TEM)) NIL)) (SETQ TEM (CDR TEM))) (T (* GETSETQ adds
the info to alist, or ERROR's - let it handle unrecognized NLISTP's
as well) (GETSETQ TEM ALIST FIELDS COMPOSESTATEMENT))) (COND ((SETQ
TEM (CDR TEM)) (GO LP2))) (AND USING COPYING (RECORDERROR (LIST (QUOTE
"both") (CAR COPYING) (QUOTE "and") (CAR USING)) TEM COMPOSESTATEMENT))
(SETQ TEM (OR USING COPYING)) (SETQ DEF (RECCOMPOSE1 (COND (
TYPERECORDFLG (CDR (CADDR FIELDS))) (T (CADDR FIELDS))) (AND TEM (COND
((NOT (EASYCOMPUTE (CADR TEM))) (SETQ TEMVAR (LIST (LIST (QUOTE $$TEM)
(COND (TYPERECORDFLG ('CDR (CADR TEM))) (T (CADR TEM)))))) (CAAR TEMVAR))
(TYPERECORDFLG ('CDR (CADR TEM))) (T (CADR TEM)))))) (COND (TEMVAR
(SETQ DEF (LIST (QUOTE PROG) TEMVAR DEF)))) (SETQ TEM1 (CONS (CAR
CREATE) (CONS (CADR CREATE) (NCONC (COND (USING (LIST (CAR USING)
(CADR USING))) (COPYING (LIST (CAR COPYING) (CADR COPYING))) (DEFAULT
(LIST (CAR DEFAULT) (CADR DEFAULT)))) (for TEM in ALIST WHEN (CDR
TEM) join (LIST (PACK (LIST (CAR TEM) (QUOTE ←))) (CADR TEM)))))))
(/RPLNODE COMPOSESTATEMENT (CAR TEM1) (CDR TEM1)) (CLISPTRAN 
COMPOSESTATEMENT (COND (TYPERECORDFLG ('CONS (KWOTE TYPERECORDFLG)
DEF)) (T DEF)))) COMPOSESTATEMENT))

('CAR
(LAMBDA (X) (AND X (PROG (TEM) (COND ((NULL (SETQ TEM (CADR (FASSOC
(CAR X) CRLIST)))) (LIST (QUOTE CAR) X)) (T (LIST TEM (CADR X))))))))

('CDR
(LAMBDA (X) (AND X (PROG (TEM) (COND ((NULL (SETQ TEM (CADDR (FASSOC
(CAR X) CRLIST)))) (LIST (QUOTE CDR) X)) (T (LIST TEM (CADR X))))))))

('CONS
(LAMBDA (CARPART CDRPART) (COND ((OR (EQ (CAR CDRPART) (QUOTE LIST))
(NOT (CAR CDRPART))) (CONS (QUOTE LIST) (CONS CARPART (CDR CDRPART))))
(T (LIST (QUOTE CONS) CARPART CDRPART)))))

(RECCOMPOSE1
(LAMBDA (FIELDS DEF) (PROG (K (BLIP (CONS))) (* BLIP is used as a
value of RECCOMPOSE2 when NO field is specified, and something needs
to be returned to distinguish it from NIL (i.e. (CREATE FOO USING
FIE FUM←NIL))) (COND ((NEQ (SETQ K (RECCOMPOSE2 FIELDS DEF)) BLIP)
(* RECCOMPOSE2 returns <expression> to distinguish FIELD←NIL from
the field being not specified) K) (T (* If no USING or COPYING were
specified, COPYING NIL is assumed; thus RECCOMPOSE returning NIL means
that we had a USING) DEF)))))

(RECCOMPOSE2
(LAMBDA (FIELD DEF) (* Constructs the composition of FIELD , returning
NIL if none of the fields in FIELD are mentioned in the CREATE 
expression and there isn't a default for any of the fields - and 
<consexpression> otherwise) (PROG (TEM1 TEM2) (COND ((LISTP FIELD)
(SETQ TEM1 (RECCOMPOSE2 (CAR FIELD) ('CAR DEF))) (SETQ TEM2 (RECCOMPOSE2
(CDR FIELD) ('CDR DEF))) (* if both are NIL, means that (1) USING
specified; (2) no fields were specified - if only one is non-NIL,
the other comes from USING) (COND ((AND (EQ TEM1 BLIP) (EQ TEM2 BLIP))
NIL) (T ('CONS (COND ((NEQ TEM1 BLIP) (CAR TEM1)) (T ('CAR DEF)))
(COND ((NEQ TEM2 BLIP) (CAR TEM2)) (T ('CDR DEF))))))) ((AND FIELD
(CDR (SETQ TEM1 (FASSOC FIELD ALIST)))) (* The field was specified)
(CADR TEM1)) (USING (* Will get def back at higher level when it is
discovered that "other half" of the CONS is needed) BLIP) (COPYING
DEF) ((AND FIELD (SETQ TEM1 (FASSOC FIELD DEFAULTS))) (* The field
has a default) (CADR TEM1)) (DEFAULT (* There is a universal default)
(CADR DEFAULT)) (T NIL)))))

(RECCOMPOSE4
(LAMBDA (FIELD) (* HERE, WE KNOW THAT NONE OF THE FIELDS HAVE BEEN
SPECIFIED, AND THERE IS NO DEFAULTS) (COND ((NLISTP FIELD) NIL) (T
('CONS (RECCOMPOSE4 (CAR FIELD)) (RECCOMPOSE4 (CDR FIELD)))))))

(MAKECROPFN1
(LAMBDA (RCROPS) (COND ((NULL RCROPS) (QUOTE RECORDFIELDVAR)) ((NULL
(CDDDDR RCROPS)) (LIST (PACK (CONS (QUOTE C) (APPEND RCROPS (QUOTE
(R))))) (QUOTE RECORDFIELDVAR))) (T (LIST (MKATOM (CONCAT (QUOTE C)
(CAR RCROPS) (CADR RCROPS) (CADDR RCROPS) (CADDDR RCROPS) (QUOTE R)))
(MAKECROPFN1 (CDDDDR RCROPS)))))))

(FIELDSIN
(LAMBDA (X) (COND ((NULL X) NIL) ((NLISTP X) (LIST X)) (T (NCONC (
FIELDSIN (CAR X)) (FIELDSIN (CDR X)))))))

(/PUTDTST
(LAMBDA (ATM DEF) (COND ((NOT (FGETD ATM)) (/PUTD ATM DEF)) ((EQUAL
DEF (GETD ATM))) (T (VIRGINFN ATM T) (COND ((NULL DFNFLG) (LISPXPRINT
(CONS ATM (QUOTE (redefined))) T) (SAVEDEF ATM))) (/PUTD ATM DEF)))))

(FIELDDEFS
(LAMBDA (FORMAT RCROPS) (COND ((NULL FORMAT) NIL) ((LISTP FORMAT)
(NCONC (FIELDDEFS (CAR FORMAT) (CONS (QUOTE A) RCROPS)) (FIELDDEFS
(CDR FORMAT) (CONS (QUOTE D) RCROPS)))) ((LITATOM FORMAT) (LIST (LIST
FORMAT (MAKECROPFN1 RCROPS)))) (T (ERROR "Invalid record field" FORMAT))))
)

(MYSUBST
(LAMBDA (SEXPR) (* SUBSTS EXPR::3 for (RECORDFIELDVAR) IN SEXPR returns
NIL if RECORDFIELDVAR not found) (COND ((NLISTP SEXPR) NIL) ((EQ (CAR
SEXPR) (QUOTE RECORDFIELDVAR)) SUBSTEXPR) (T (PROG ((A (MYSUBST (CAR
SEXPR))) (D (MYSUBST (CDR SEXPR)))) (AND (NULL A) (NULL D) (RETURN))
(CONS (OR A (CAR SEXPR)) (OR D (CDR SEXPR))))))))

(MAKERPLAC2
(LAMBDA (FORM) (PROG (TEM) (OR (SETQ TEM (CDDDR (FASSOC (CAR FORM)
CRLIST))) (HELP)) (CONS (SELECTQ (CAR TEM) (CAR (QUOTE RPLACA)) (CDR
(QUOTE RPLACD)) (HELP)) (CONS (COND ((CADR TEM) (LIST (CADR TEM) (CADR
FORM))) (T (CADR FORM))) (QUOTE (VALUE)))))))

(RECORDCLISPLOOKUP
(LAMBDA (WORD VAR1 VAR2 LISPFN CLASS) (* In most cases, it is not
necessary to do a full lookup. This is q uick an dirty check inside
of the block to avoid calling CLISPLOOKUP0 It will work whenever there
are no local declarations.) (PROG (TEM) (RETURN (COND ((AND (OR CLASS
(SETQ CLASS (GETP WORD (QUOTE CLISPCLASS)))) (SETQ TEM (GETLOCALDEC
EXPR FAULTFN))) (* must do full lookup.) (CLISPLOOKUP0 WORD VAR1 VAR2
TEM LISPFN CLASS)) (T (SELECTQ CLASS (VALUE (CAR WORD)) ((RECORD 
RECORDFIELD) NIL) (OR LISPFN (GETP WORD (QUOTE LISPFN)) WORD))))))))

(RECRESPELL
(LAMBDA (FIELD DECLST TAIL) (FIXSPELL FIELD 70 (NCONC (MAPCONC DECLST
(FUNCTION (LAMBDA (X) (APPEND (CAR (RECORDECL X)))))) RECORDSPLIST)
NIL TAIL NIL T)))

(CLISPNOTRAN
(LAMBDA (X) (COND ((AND (LISTP X) (EQ (CAR X) CLISPTRANFLG)) (CDDR
X)) (T X))))

(CREATE?
(LAMBDA (X) (OR (EQ X (QUOTE create)) (EQ X (QUOTE CREATE)))))

(GETLOCALDEC
(LAMBDA (EXPR FN) (PROG (TEM) (RETURN (COND ((AND (EQ (CAR (SETQ TEM
(CADDR EXPR))) (QUOTE *)) (EQ (CADR TEM) (QUOTE DECLARATIONS:))) (CDDR
TEM)) ((EQ (CAR TEM) (QUOTE CLISP:)) (CLISPDEC0 TEM (OR FN FAULTFN)))))))
)

(RECLOOK
(LAMBDA (RECNAME TAIL LOCALDEC) (* LOOKS FOR RECORD DECLARATION) (PROG
(TEM) RETRY (OR (COND ((NLISTP RECNAME) (OR (AND LOCALDEC (CLISPLOOKUP0
RECNAME NIL NIL LOCALDEC NIL (QUOTE RECORD))) (GETP RECNAME (QUOTE
CLISPRECORD)) (COND ((SETQ TEM (FIXSPELL RECNAME 70 (NCONC (MAPCONC
LOCALDEC (FUNCTION (LAMBDA (X) (AND (OR (EQ (CAR X) (QUOTE TYPERECORD))
(EQ (CAR X) (QUOTE RECORD)) (EQ (CAR X) CLISPTRANFLG)) (NLISTP (CADR
X)) (LIST (CADR X)))))) USERRECORDS) NIL TAIL NIL T)) (SETQ RECNAME
TEM) (GO RETRY))))) ((OR (EQ (CAR RECNAME) (QUOTE RECORD)) (EQ (CAR
RECNAME) (QUOTE TYPERECORD)) (AND (EQ (CAR RECNAME) CLISPTRANFLG)
(FMEMB (CADDR RECNAME) (QUOTE (RECORD TYPERECORD))))) RECNAME)) (ERROR
RECNAME "not a record" T)))))

(DWIMIFYREC
(LAMBDA (TAIL NEWVARS PARENT) (PROG ((VARS (APPEND NEWVARS VARS)))
(DWIMIFY1B TAIL PARENT TAIL T NIL FAULTFN))))

(EASYCOMPUTE
(LAMBDA (X) (OR (NLISTP X) (AND (SELECTQ (CAR X) ((CAR CDR) T) (GETP
(CAR X) (QUOTE CROPS))) (NLISTP (CADR X))))))

(GLOBALRECORD
(LAMBDA (FIELD) (PROG (TEM CLASS) (FRPLACD (CDR FIELD) (LIST (MAKERPLAC2
(CADR FIELD)) (PACK (LIST (QUOTE GET.) (CAR FIELD))) (PACK (LIST (QUOTE
REPLACE.) (CAR FIELD))) (PACK (LIST (QUOTE /REPLACE.) (CAR FIELD)))
(PACK (LIST (QUOTE FREPLACE.) (CAR FIELD))))) (* NOW FIELD IS (NAME
DEF RPLDEF GETFN PUTFN /PUTFN FPUTFN)) (SETQ TEM (/PUT (CADDDR FIELD)
(QUOTE MACRO) (LIST (QUOTE (RECORDFIELDVAR)) (CADR FIELD)))) (/PUTDTST
(CADDDR FIELD) (OR (AND (NLISTP (CADADR FIELD)) (GETD (CAADR FIELD)))
(CONS (QUOTE LAMBDA) TEM))) (/PUT (CAR FIELD) (QUOTE ACCESSFN) (CONS
(CADDDR FIELD) (CAR (CDDDDR FIELD)))) (/PUT (CADDDR FIELD) (QUOTE
ACCESSFN) (CAR FIELD)) (SETQ TEM (SELECTQ (CAR (CADDR FIELD)) (RPLACA
(QUOTE (RPLACA /RPLACA FRPLACA))) (RPLACD (QUOTE (RPLACD /RPLACD FRPLACD)))
(HELP))) (/PUT (CAR (CDDDDR FIELD)) (QUOTE LISPFN) (SELECTQ (GETP
(QUOTE RPLACA) (QUOTE LISPFN)) (RPLACA (CAR (CDDDDR FIELD))) (/RPLACA
(CADR (CDDDDR FIELD))) (FRPLACA (CADDR (CDDDDR FIELD))) (HELP))) (/PUT
(CAR (CDDDDR FIELD)) (QUOTE CLISPCLASSDEF) (CONS (QUOTE ACCESS) (CDDDDR
FIELD))) (FOR X IN TEM AS Y IN (CDDDDR FIELD) DO (SETQ TEM (LIST (QUOTE
(RECORDFIELDVAR VALUE)) (CONS X (CDR (CADDR FIELD))))) (/PUTDTST Y
(OR (AND (NLISTP (CADR (CADDR FIELD))) (GETD X)) (CONS (QUOTE LAMBDA)
TEM))) (/PUT Y (QUOTE LISPFN) (CAR (CDDDDR FIELD))) (/PUT Y (QUOTE
MACRO) TEM) (/PUT Y (QUOTE ACCESSFN) (CONS (CAR FIELD) Y))))))

(CLISPGLOBALREC
(LAMBDA (FIELD) (PROG (TEM CLASS) (FRPLACD (CDR FIELD) (LIST (MAKERPLAC2
(CADR FIELD)) (PACK (LIST (QUOTE GET.) (CAR FIELD))) (PACK (LIST (QUOTE
REPLACE.) (CAR FIELD))) (PACK (LIST (QUOTE /REPLACE.) (CAR FIELD)))
(PACK (LIST (QUOTE FREPLACE.) (CAR FIELD))))) (* NOW FIELD IS (NAME
DEF RPLDEF GETFN PUTFN /PUTFN FPUTFN)) (SETQ TEM (/PUT (CADDDR FIELD)
(QUOTE MACRO) (LIST (QUOTE (RECORDFIELDVAR)) (CADR FIELD)))) (/PUTDTST
(CADDDR FIELD) (OR (AND (NLISTP (CADADR FIELD)) (GETD (CAADR FIELD)))
(CONS (QUOTE LAMBDA) TEM))) (/PUT (CAR FIELD) (QUOTE ACCESSFN) (CONS
(CADDDR FIELD) (CAR (CDDDDR FIELD)))) (/PUT (CADDDR FIELD) (QUOTE
ACCESSFN) (CAR FIELD)) (SETQ TEM (SELECTQ (CAR (CADDR FIELD)) (RPLACA
(QUOTE (RPLACA /RPLACA FRPLACA))) (RPLACD (QUOTE (RPLACD /RPLACD FRPLACD)))
(HELP))) (/PUT (CAR (CDDDDR FIELD)) (QUOTE LISPFN) (SELECTQ (GETP
(QUOTE RPLACA) (QUOTE LISPFN)) (RPLACA (CAR (CDDDDR FIELD))) (/RPLACA
(CADR (CDDDDR FIELD))) (FRPLACA (CADDR (CDDDDR FIELD))) (HELP))) (/PUT
(CAR (CDDDDR FIELD)) (QUOTE CLISPCLASSDEF) (CONS (QUOTE ACCESS) (CDDDDR
FIELD))) (FOR X IN TEM AS Y IN (CDDDDR FIELD) DO (SETQ TEM (LIST (QUOTE
(RECORDFIELDVAR VALUE)) (CONS X (CDR (CADDR FIELD))))) (/PUTDTST Y
(OR (AND (NLISTP (CADR (CADDR FIELD))) (GETD X)) (CONS (QUOTE LAMBDA)
TEM))) (/PUT Y (QUOTE LISPFN) (CAR (CDDDDR FIELD))) (/PUT Y (QUOTE
MACRO) TEM) (/PUT Y (QUOTE ACCESSFN) (CONS (CAR FIELD) Y))))))

(RECLISPLOOKUP
(LAMBDA (WORD VAR1 DECLST LISPFN) (PROG (CLASS) (COND ((AND (SETQ
CLASS (GETP WORD (QUOTE CLISPCLASS))) DECLST) (CLISPLOOKUP0 WORD VAR1
NIL DECLST LISPFN CLASS)) (T (OR LISPFN WORD))))))

(GETSETQ
(LAMBDA (TAIL ALIST RECDEC PARENT) (PROG (TEM1) LP2 (RECORDERROR (COND
((LISTP (CAR TAIL)) (OR (SELECTQ (CAAR TAIL) ((SETQ SAVESETQ) (OR
(CDDR (CAR TAIL)) (/RPLACD (CDAR TAIL) (CONS))) NIL) ((SETQQ SAVESETQQ)
(/RPLNODE (CAR TAIL) (QUOTE SETQ) (LIST (CADAR TAIL) (KWOTE (CADDR
(CAR TAIL))))) NIL) (QUOTE NOFIELD)) (COND ((SETQ TEM1 (FASSOC (CADAR
TAIL) ALIST)) (COND ((CDR TEM1) "field specified twice") (T (RETURN
(FRPLACD TEM1 (CDDAR TAIL)))))) ((FIXSPELL (CADAR TAIL) 70 (CAR RECDEC)
NIL (CDAR TAIL) NIL T) (GO LP2)) (T (QUOTE FIELDS))))) (T (QUOTE 
NOFIELDS))) TAIL PARENT))))

(RECORDERROR
(LAMBDA (MESSAGE AT IN) (* poor substitute for CLISPERROR) (ERROR
(SELECTQ MESSAGE (NOFIELDS "missing Field ← ") (FIELDS 
"unrecognized Field ") MESSAGE) AT T)))
)
(DEFLIST(QUOTE(
(CREATE (RECORDWORD . create))
(create (RECORDWORD . create))
(USING (RECORDWORD . using))
(using (RECORDWORD . using))
))(QUOTE CLISPWORD))

(DEFLIST(QUOTE(
(RECORDS (LAMBDA (X Y) (AND (EQ (CAR X) Y) (CDR X))))
))(QUOTE PRETTYTYPE))

(ADDTOVAR PRETTYTYPELST (CHANGEDRECLST RECORDS "records"))
(ADDTOVAR PRETTYMACROS (RECORDS X (E (MAPC (QUOTE X) (FUNCTION (LAMBDA
(Z) (PRINT (SELECTQ (CAR (SETQ Z (CLISPNOTRAN (OR (LISTP Z) (LISTP
(GETP Z (QUOTE RECORD))))))) ((RECORD TYPERECORD) Z) (ERROR Z 
"not a record")))))))))
(RPAQQ CRLIST ((CAR CAAR CDAR CAR NIL) (CDR CADR CDDR CDR NIL) (CDDDDR
NIL NIL CDR CDDDR) (CADDDR NIL NIL CAR CDDDR) (CDDDR CADDDR CDDDDR
CDR CDDR) (CDADDR NIL NIL CDR CADDR) (CAADDR NIL NIL CAR CADDR) (CADDR
CAADDR CDADDR CAR CDDR) (CDDR CADDR CDDDR CDR CDR) (CDDADR NIL NIL
CDR CDADR) (CADADR NIL NIL CAR CDADR) (CDADR CADADR CDDADR CDR CADR)
(CDAADR NIL NIL CDR CAADR) (CAAADR NIL NIL CAR CAADR) (CAADR CAAADR
CDAADR CAR CADR) (CADR CAADR CDADR CAR CDR) (CDDDAR NIL NIL CDR CDDAR)
(CADDAR NIL NIL CAR CDDAR) (CDDAR CADDAR CDDDAR CDR CDAR) (CDADAR
NIL NIL CDR CADAR) (CAADAR NIL NIL CAR CADAR) (CADAR CAADAR CDADAR
CAR CDAR) (CDAR CADAR CDDAR CDR CAR) (CDDAAR NIL NIL CDR CDAAR) (CADAAR
NIL NIL CAR CDAAR) (CDAAR CADAAR CDDAAR CDR CAAR) (CDAAAR NIL NIL
CDR CAAAR) (CAAAAR NIL NIL CAR CAAAR) (CAAAR CAAAAR CDAAAR CAR CAAR)
(CAAR CAAAR CDAAR CAR CAR)))
(RPAQ RECORDSPLIST (LIST NIL))
(RPAQ CHANGEDRECLST NIL)
(RPAQ USERRECORDS NIL)
(RPAQ RECORDTRANFLG T)
(RPAQQ RECORDREPLACEVALUEFLG T)
(DECLARE
(BLOCK: RECORDBLOCK TYPERECORD RECORD CLISPRECORD RECRESPELL RECLOOK
DWIMIFYREC RECORDECL RECCOMPOSE0 'CAR 'CDR 'CONS RECCOMPOSE1 RECCOMPOSE2
RECCOMPOSE4 MAKECROPFN1 FIELDSIN /PUTDTST FIELDDEFS MYSUBST 
RECORDCLISPLOOKUP MAKERPLAC2 CREATE? GETLOCALDEC EASYCOMPUTE (ENTRIES
RECORD TYPERECORD RECCOMPOSE0 CLISPRECORD RECORDECL CLISPNOTRAN) (
LOCALFREEVARS FROMVAR SUBSTEXPR ALIST COMPOSESTATEMENT) (GLOBALVARS
RECORDSPLIST CRLIST USERRECORDS CHANGEDRECLST RECORDREPLACEVALUEFLG)
(SPECVARS VARS))
)(ADDSPELL (QUOTE CREATE) SPELLINGS2)
(ADDSPELL (QUOTE USING) SPELLINGS2)
STOP